home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / electric.el.z / electric.el
Encoding:
Text File  |  1998-10-28  |  6.4 KB  |  179 lines
  1. ;;; electric.el --- window maker and Command loop for `electric' modes.
  2.  
  3. ;; Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: K. Shane Hartman
  6. ;; Maintainer: FSF
  7. ;; Keywords: extensions
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ; zaaaaaaap
  29.  
  30. ;;; Code:
  31.  
  32. ;; This loop is the guts for non-standard modes which retain control
  33. ;; until some event occurs.  It is a `do-forever', the only way out is
  34. ;; to throw.  It assumes that you have set up the keymap, window, and
  35. ;; everything else: all it does is read commands and execute them -
  36. ;; providing error messages should one occur (if there is no loop
  37. ;; function - which see).  The required argument is a tag which should
  38. ;; expect a value of nil if the user decides to punt. The second
  39. ;; argument is the prompt to be used: if nil, use "->", if 'noprompt,
  40. ;; don't use a prompt, if a string, use that string as prompt, and if
  41. ;; a function of no variable, it will be evaluated in every iteration
  42. ;; of the loop and its return value, which can be nil, 'noprompt or a
  43. ;; string, will be used as prompt.  Given third argument non-nil, it
  44. ;; INHIBITS quitting unless the user types C-g at toplevel.  This is
  45. ;; so user can do things like C-u C-g and not get thrown out.  Fourth
  46. ;; argument, if non-nil, should be a function of two arguments which
  47. ;; is called after every command is executed.  The fifth argument, if
  48. ;; provided, is the state variable for the function.  If the
  49. ;; loop-function gets an error, the loop will abort WITHOUT throwing
  50. ;; (moral: use unwind-protect around call to this function for any
  51. ;; critical stuff).  The second argument for the loop function is the
  52. ;; conditions for any error that occurred or nil if none.
  53.  
  54. (defun Electric-command-loop (return-tag
  55.                   &optional prompt inhibit-quit
  56.                     loop-function loop-state)
  57.  
  58.   (let (cmd 
  59.         (err nil) 
  60.         (prompt-string prompt))
  61.     (while t
  62.       (if (not (or (stringp prompt) (eq prompt nil) (eq prompt 'noprompt)))
  63.           (setq prompt-string (funcall prompt)))
  64.       (if (not (stringp prompt-string))
  65.           (if (eq prompt-string 'noprompt)
  66.               (setq prompt-string nil)
  67.             (setq prompt-string "->")))
  68.       (setq cmd (read-key-sequence prompt-string))
  69.       (setq last-command-char (aref cmd (1- (length cmd)))
  70.         this-command (key-binding cmd t)
  71.         cmd this-command)
  72.       ;; This makes universal-argument-other-key work.
  73.       (setq universal-argument-num-events 0)
  74.       (if (or (prog1 quit-flag (setq quit-flag nil))
  75.           (eq last-input-char ?\C-g))
  76.       (progn (setq unread-command-events nil
  77.                prefix-arg nil)
  78.          ;; If it wasn't cancelling a prefix character, then quit.
  79.          (if (or (= (length (this-command-keys)) 1)
  80.              (not inhibit-quit)) ; safety
  81.              (progn (ding)
  82.                 (message "Quit")
  83.                 (throw return-tag nil))
  84.            (setq cmd nil))))
  85.       (setq current-prefix-arg prefix-arg)
  86.       (if cmd
  87.       (condition-case conditions
  88.           (progn (command-execute cmd)
  89.              (setq last-command this-command)
  90.              (if (or (prog1 quit-flag (setq quit-flag nil))
  91.                  (eq last-input-char ?\C-g))
  92.              (progn (setq unread-command-events nil)
  93.                 (if (not inhibit-quit)
  94.                     (progn (ding)
  95.                        (message "Quit")
  96.                        (throw return-tag nil))
  97.                   (ding)))))
  98.         (buffer-read-only (if loop-function
  99.                   (setq err conditions)
  100.                 (ding)
  101.                 (message "Buffer is read-only")
  102.                 (sit-for 2)))
  103.         (beginning-of-buffer (if loop-function
  104.                      (setq err conditions)
  105.                    (ding)
  106.                    (message "Beginning of Buffer")
  107.                    (sit-for 2)))
  108.         (end-of-buffer (if loop-function
  109.                    (setq err conditions)
  110.                  (ding)
  111.                  (message "End of Buffer")
  112.                  (sit-for 2)))
  113.         (error (if loop-function
  114.                (setq err conditions)
  115.              (ding)
  116.              (message "Error: %s"
  117.                   (if (eq (car conditions) 'error)
  118.                   (car (cdr conditions))
  119.                 (prin1-to-string conditions)))
  120.              (sit-for 2))))
  121.     (ding))
  122.       (if loop-function (funcall loop-function loop-state err))))
  123.   (ding)
  124.   (throw return-tag nil))
  125.  
  126. ;; This function is like pop-to-buffer, sort of. 
  127. ;; The algorithm is
  128. ;; If there is a window displaying buffer
  129. ;;     Select it
  130. ;; Else if there is only one window
  131. ;;     Split it, selecting the window on the bottom with height being
  132. ;;     the lesser of max-height (if non-nil) and the number of lines in
  133. ;;      the buffer to be displayed subject to window-min-height constraint.
  134. ;; Else
  135. ;;     Switch to buffer in the current window.
  136. ;;
  137. ;; Then if max-height is nil, and not all of the lines in the buffer
  138. ;; are displayed, grab the whole frame.
  139. ;;
  140. ;; Returns selected window on buffer positioned at point-min.
  141.  
  142. (defun Electric-pop-up-window (buffer &optional max-height)
  143.   (let* ((win (or (get-buffer-window buffer) (selected-window)))
  144.      (buf (get-buffer buffer))
  145.      (one-window (one-window-p t))
  146.      (pop-up-windows t)
  147.      (target-height)
  148.      (lines))
  149.     (if (not buf)
  150.     (error "Buffer %s does not exist" buffer)
  151.       (save-excursion
  152.     (set-buffer buf)
  153.     (setq lines (count-lines (point-min) (point-max)))
  154.     (setq target-height
  155.           (min (max (if max-height (min max-height (1+ lines)) (1+ lines))
  156.             window-min-height)
  157.            (save-window-excursion
  158.              (delete-other-windows)
  159.              (1- (window-height (selected-window)))))))
  160.       (cond ((and (eq (window-buffer win) buf))
  161.          (select-window win))
  162.         (one-window
  163.          (goto-char (window-start win))
  164.          (pop-to-buffer buffer)
  165.          (setq win (selected-window))
  166.          (enlarge-window (- target-height (window-height win))))
  167.         (t
  168.          (switch-to-buffer buf)))
  169.       (if (and (not max-height)
  170.            (> target-height (window-height (selected-window))))
  171.       (progn (goto-char (window-start win))
  172.          (enlarge-window (- target-height (window-height win)))))
  173.       (goto-char (point-min))
  174.       win)))
  175.  
  176. (provide 'electric)
  177.  
  178. ;;; electric.el ends here
  179.